home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Disc to the Future 2
/
Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin
/
MAC
/
LISP
/
GAMBIT_1
/
GRAPHICS.SCM
< prev
next >
Wrap
Text File
|
1992-03-18
|
9KB
|
274 lines
; Graphics examples
;
; mandala and koch were originally written for MacScheme.
; sierpinsky was originally written in Modula2.
; Utilities
(define (move-to x y)
(mac#moveto (floor (inexact->exact x)) (floor (inexact->exact y))))
(define (line-to x y)
(mac#lineto (floor (inexact->exact x)) (floor (inexact->exact y))))
(define (draw-line x1 y1 x2 y2)
(mac#moveto (floor (inexact->exact x1)) (floor (inexact->exact y1)))
(mac#lineto (floor (inexact->exact x2)) (floor (inexact->exact y2))))
; Mandala
;
; try: (mandala 140 30)
;
; Note: floating point is really slow if you don't have a FPU. This is
; because every 68881 instruction has to be emulated in software. A lot
; of time is spent in 'inexact->exact' which converts floating point
; numbers to an exact rational representation. This is needed because
; 'floor' of a floating point number returns a floating point number.
(define (mandala r n)
(let ((w (mac#newwindow
(mac#rect 40
2
(+ 40 (floor (inexact->exact (* (+ r 5) 2))))
(+ 2 (floor (inexact->exact (* (+ r 5) 2)))))
"Mandala"
#f)))
(if (not (= w 0))
(begin
(mac#setport w)
(mand (+ r 5) (+ r 5) r n)
(mac#disposewindow w)))))
(define (mand x0 y0 radius npoints) ; example modified from MacScheme
(move-to (+ x0 radius) y0)
(do ((x (make-vector npoints))
(y (make-vector npoints))
(i (- npoints 1) (- i 1))
(delta (/ (* 2 3.14159265) npoints))
(theta 0 (+ theta delta)))
((negative? i)
(line-to (vector-ref x (- npoints 1))
(vector-ref y (- npoints 1)))
(do ((i (- (quotient npoints 2) 1) (- i 1)))
((negative? i))
(do ((j 0 (+ j 1)))
((= j npoints))
(move-to (vector-ref x j) (vector-ref y j))
(line-to
(vector-ref x (remainder (+ j i) npoints))
(vector-ref y (remainder (+ j i) npoints))))))
(vector-set! x i (round (inexact->exact (+ x0 (* radius (cos theta))))))
(vector-set! y i (round (inexact->exact (+ y0 (* radius (sin theta))))))
(line-to (vector-ref x i) (vector-ref y i))))
; Koch
;
; try: (koch 4)
;
; Once again, this is really slow if you don't have a FPU.
(define (koch n)
(let ((w (mac#newwindow (mac#rect 40 2 240 202) "Koch" #f)))
(if (not (= w 0))
(begin
(mac#setport w)
(fractal1-for-half-window 101 101 60 n)
(mac#disposewindow w)))))
(define fractal1-for-half-window
(lambda (xorig yorig scaling n)
(letrec ((sin60 .866)
(side
(lambda (x1 y1 x2 y2 n)
(if (= n 1)
(draw-line (+ x1 xorig)
(+ y1 yorig)
(+ x2 xorig)
(+ y2 yorig))
(let ((xdiff (- x2 x1))
(ydiff (- y2 y1)))
(let ((x3 (+ x1 (round (/ xdiff 3))))
(y3 (+ y1 (round (/ ydiff 3))))
(x4 (+ x1 (round (- (/ xdiff 2)
(/ (* ydiff sin60)
3)))))
(y4 (+ y1 (round (+ (/ ydiff 2)
(/ (* xdiff sin60)
3)))))
(x5 (+ x1 (round (/ (* xdiff 2) 3))))
(y5 (+ y1 (round (/ (* ydiff 2) 3)))))
(begin
(side x1 y1 x3 y3 (- n 1))
(side x3 y3 x4 y4 (- n 1))
(side x4 y4 x5 y5 (- n 1))
(side x5 y5 x2 y2 (- n 1)))))))))
(let
((x1 0)
(y1 (round (* scaling sin60)))
(x2 (round scaling))
(y2 (- (round (* scaling sin60))))
(x3 (- (round scaling)))
(y3 (- (round (* scaling sin60)))))
(begin
(side x1 y1 x2 y2 n)
(side x2 y2 x3 y3 n)
(side x3 y3 x1 y1 n))))))
; Sierpinsky
;
; try: (sierpinsky 5)
(define (sierpinsky n)
(define h 2)
(define border 10)
(define size 256)
(define (refresh line)
(define (sierp j)
(let* ((h (/ (/ size 4) (expt 2 j)))
(current-x (+ border (* h 2)))
(current-y (+ border h)))
(define (draw d l)
(let ((inc-x (case d ((0 1 7) l) ((3 4 5) (- l)) (else 0)))
(inc-y (case d ((1 2 3) l) ((5 6 7) (- l)) (else 0))))
(line current-x current-y
(+ current-x inc-x) (- current-y inc-y))
(set! current-x (+ current-x inc-x))
(set! current-y (- current-y inc-y))
#f))
(define (s k i)
(if (> k 0)
(let ((k (- k 1)))
(s k i ) (draw (modulo (- i 1) 8) h)
(s k (modulo (+ i 6) 8)) (draw i (* h 2))
(s k (modulo (+ i 2) 8)) (draw (modulo (+ i 1) 8) h)
(s k i ))))
(define (ss k)
(s k 0) (draw 7 h)
(s k 6) (draw 5 h)
(s k 4) (draw 3 h)
(s k 2) (draw 1 h))
(ss j)))
(let loop ((j 0))
(if (<= j n)
(begin
(sierp j)
(loop (+ j 1))))))
(let ((w (mac#newwindow (mac#rect 40 2
(+ 40 size (* border 2))
(+ 2 size (* border 2)))
(string-append "(sierpinsky " (number->string n) ")")
#f)))
(if (not (= w 0))
(begin
(mac#setport w)
(refresh draw-line)
(mac#disposewindow w)))))
; Bounce
;
; try: (bounce)
(define (bounce)
(define n 1)
(define radius 5)
(define sqr-2*radius 100)
(define w 200)
(define old #f) ; old state
(define new #f) ; new state
(define (compute-new-state)
(let loop1 ((i (- n 1)))
(if (>= i 0)
(let* ((b-old (vector-ref old i))
(b-new (vector-ref new i))
(vx (vector-ref b-old 2))
(vy (vector-ref b-old 3))
(x (+ (vector-ref b-old 0) vx))
(y (+ (vector-ref b-old 1) vy))
(r (vector-ref b-new 4)))
(vector-set! b-new 0 x)
(vector-set! b-new 1 y)
(vector-set! b-new 2
(if (or (< x radius) (> x (- w radius))) (- vx) vx))
(vector-set! b-new 3
(if (or (< y radius) (> y (- w radius))) (- vy) vy))
(mac#rect-top-set! r (- y radius))
(mac#rect-left-set! r (- x radius))
(mac#rect-bottom-set! r (+ y radius))
(mac#rect-right-set! r (+ x radius))
(loop1 (- i 1))))))
(define (display-new-state)
(let loop ((i (- n 1)))
(if (>= i 0)
(begin
(mac#invertoval (vector-ref (vector-ref old i) 4))
(mac#invertoval (vector-ref (vector-ref new i) 4))
(loop (- i 1))))))
(define (bounce-balls)
(compute-new-state)
(display-new-state)
(let ((temp new))
(set! new old)
(set! old temp))
(if (not (mac#button)) (bounce-balls)))
(set! old
(let ((state (make-vector n)))
(let loop ((i (- n 1)))
(if (>= i 0)
(let ((v (vector (floor (+ radius (* (rand) (- w (* 2 radius)))))
(floor (+ radius (* (rand) (- w (* 2 radius)))))
(floor (* (rand) radius))
(floor (* (rand) radius))
(mac#rect 0 0 0 0))))
(vector-set! state i v)
(loop (- i 1)))
state))))
(set! new
(let ((state (make-vector n)))
(let loop ((i (- n 1)))
(if (>= i 0)
(let ((v (vector 0 0 0 0 (mac#rect 0 0 0 0))))
(vector-set! state i v)
(loop (- i 1)))
state))))
(let ((w (mac#newwindow (mac#rect 40 2 (+ w 40) (+ w 2)) "Bounce" #f)))
(if (not (= w 0))
(begin
(mac#setport w)
(bounce-balls)
(mac#disposewindow w)))))
(define *seed* 222498987)
(define (rand)
(let* ((hi (quotient *seed* 127773))
(lo (modulo *seed* 127773))
(test (- (* 16807 lo) (* 2836 hi))))
(if (> test 0)
(set! *seed* test)
(set! *seed* (+ test 2147483647)))
(/ *seed* 2147483648)))